home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / stack.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  6.9 KB  |  199 lines
  1. D,#TD1PsT[Begin using 006 escapes];; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:cptfont -*-
  2. ;;
  3. ;; (C) Copyright 1982 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;; This file is part of the BOXER system.
  17. ;;
  18.  
  19. ;;;; BOXER-TOP-OF-STACK-GROUP-BINDINGS
  20.  
  21. (DEFVAR *BOXER-TOP-OF-STACK-GROUP-BINDINGS*
  22.     '((TERMINAL-IO *BOXER-PANE*)
  23.       (SYS:*BREAK-BINDINGS* *BOXER-BREAK-BINDINGS*)
  24.       (TV:KBD-INTERCEPTED-CHARACTERS *BOXER-KBD-INTERCEPTED-CHARACTERS*)
  25.       (BASE 10.)
  26.       (IBASE 10.)
  27.       (package (pkg-find-package "Boxer")))
  28.   "These bindings get done /"at the top/" of every Boxer
  29.    Stack Group. That is to say that every function which
  30.    is written to be the top level function of a Boxer Stack
  31.    Group should use the BOXER-TOP-OF-STACK-GROUP-BINDINGS
  32.    special form to make sure that these bindings get done.")
  33.  
  34. (DEFVAR *BOXER-BREAK-BINDINGS*
  35.     `((PACKAGE (PKG-FIND-PACKAGE 'BOXER))
  36.       (*INSIDE-LISP-BREAKPOINT-P* T)
  37.       . ,SYS:*BREAK-BINDINGS*)
  38.   "SYS:*BREAK-BINDINGS* will be lambda bound to the value of
  39.    this variable in any Boxer stack group. See the documentation
  40.    for the *BOXER-TOP-OF-STACK-GROUP-BINDINGS* variable.")
  41.  
  42. (DEFVAR *BOXER-KBD-INTERCEPTED-CHARACTERS*
  43.     (DELETE #\BREAK TV:KBD-STANDARD-INTERCEPTED-CHARACTERS))
  44.  
  45. ;;; All the support for asynchronous characters lives here now.
  46. ;;;
  47. ;;;                                  Char-Code    Translation    Even In Break And Debugger
  48. (DEFVAR *ASYNCHRONOUS-CHARACTERS* `((#\C-ABORT    ()             T) 
  49.                     (#\ABORT      #\C-ABORT      NIL)
  50.                     (#\C-M-ABORT  ()             T)
  51.                     (#\C-BREAK    ()             T)
  52.                     (#\C-M-BREAK  ()             T)))
  53.  
  54.  
  55. (DEFMETHOD (BOXER-PANE :ASYNCHRONOUS-CHARACTER-P) (CHAR-CODE)
  56.   (LET ((ENTRY (ASSQ CHAR-CODE *ASYNCHRONOUS-CHARACTERS*)))
  57.     (AND ENTRY
  58.      (OR (CADDR ENTRY)
  59.          ;; This looks (and is) slow, but it only happens when an asynchronous
  60.          ;; character is typed so it isn't really a problem since there aren't
  61.          ;; so many asynchronous characters and it isn't that slow.
  62.          (LET ((SG (SEND (SEND SELF :PROCESS) :STACK-GROUP)))
  63.            (AND (NULL  (SYMEVAL-IN-STACK-GROUP '*INSIDE-LISP-BREAKPOINT-P* SG))
  64.             (ZEROP (SYMEVAL-IN-STACK-GROUP 'DBG:*DEBUGGER-LEVEL* SG))))))))
  65.  
  66. (DEFMETHOD (BOXER-PANE :HANDLE-ASYNCHRONOUS-CHARACTER) (CHAR-CODE)
  67.   (TV:KBD-ASYNCHRONOUS-INTERCEPT-CHARACTER
  68.     (OR (CADR (ASSQ CHAR-CODE *ASYNCHRONOUS-CHARACTERS*))
  69.     CHAR-CODE) #+LMITI SELF))
  70.  
  71. ;; The BOXER-TOP-OF-STACK-GROUP-BINDINGS special form binds the various
  72. ;; things that should be bound in every boxer-stack-group. All functions
  73. ;; which are the "top-level" function of a boxer-stack-group should do
  74. ;; their body inside of this special form.
  75. (DEFMACRO BOXER-TOP-OF-STACK-GROUP-BINDINGS (&BODY BODY)
  76.   `(PROGW *BOXER-TOP-OF-STACK-GROUP-BINDINGS*
  77.      . ,BODY))
  78.  
  79.  
  80.  
  81. ;; This function starts boxer in the
  82. ;; initial boxer stack group. If you look at (:METHOD EDITOR-PANE
  83. ;; :BEFORE :INIT) you will see that it presets the Boxer process
  84. ;; to run this function.
  85. (DEFUN BOXER-PROCESS-TOP-LEVEL-FN (TERMINAL-IO)
  86.   (BOXER-TOP-OF-STACK-GROUP-BINDINGS
  87.     (TELL (POINT-BOX) :ENTER)
  88.     (BOXER-COMMAND-LOOP)))
  89.  
  90. ;;; We would like to make the editor somewhat reentrant for things like recursive edit levels
  91. ;;; this allows us to do things like call the evaluator inside of an INPUT box
  92.  
  93. (DEFMACRO BOXER-EDITOR-BINDINGS (&BODY BODY)
  94.   `(PROGV '(*REGION-BEING-DEFINED*) '(NIL)
  95.      (UNWIND-PROTECT 
  96.      (PROGN . ,BODY)
  97.        (WHEN (NOT (NULL *REGION-BEING-DEFINED*)) (FLUSH-REGION *REGION-BEING-DEFINED*)))))
  98.  
  99. (DEFUN BOXER-COMMAND-LOOP ()
  100.   (BOXER-EDITOR-BINDINGS
  101.     (ERROR-RESTART-LOOP (SI:ABORT "Boxer top level")
  102.       (OR (TELL TERMINAL-IO :LISTEN) (REDISPLAY))
  103.       (HANDLE-BOXER-INPUT (TELL TERMINAL-IO :ANY-TYI)))))
  104.  
  105. (DEFUN MINI-BOXER-COMMAND-LOOP ()
  106.   (BOXER-EDITOR-BINDINGS
  107.     (*CATCH 'MINI-COMMAND-LOOP
  108.       (LOOP DOING (OR (TELL TERMINAL-IO :LISTEN) (REDISPLAY))
  109.           (HANDLE-BOXER-INPUT (TELL TERMINAL-IO :ANY-TYI))))))
  110.  
  111. (DEFMETHOD (BOX :ENTER ) (&optional (moved-p? t))
  112.   (SETQ *BOXER-STATIC-VARIABLES-ROOT* (if (port-box? self) ports self))
  113.   (when (and moved-p? (eq entry-trigger-flag 'enabled))
  114.       (tell self :do-trigger-entry-stuff)))
  115.  
  116. ;  (if (not (null trigger))(boxer-funcall trigger)))
  117.  
  118. (DEFMETHOD (BOX :CODE) ()
  119.   (OR CACHED-CODE
  120.       (SETQ CACHED-CODE (PARSE-BOX-INTO-LAMBDA SELF))))
  121.  
  122.  
  123.  
  124.  
  125. (DEFMETHOD (BOX :AFTER :SET-NAME) (NEW-VALUE)
  126.   (WHEN (NAME-ROW? NEW-VALUE)
  127.     (TELL NEW-VALUE :SET-SUPERIOR-BOX SELF)))
  128.  
  129. (DEFMETHOD (BOX :SET-NAME) (NEW-VALUE)
  130.   (SETQ NAME NEW-VALUE))
  131.  
  132. (DEFUN GET-BOX-NAME-FOR-PRINTING (NAME)
  133.   (COND ((STRINGP NAME) NAME)
  134.     ((NULL NAME) "Un-Named")
  135.     ((NAME-ROW? NAME)(TELL NAME :TEXT-STRING))
  136.     (T "???")))
  137.  
  138. (DEFMETHOD (BOX :NAME) ()
  139.   (GET-BOX-NAME-FOR-PRINTING NAME))
  140.  
  141. (defmethod (box :entry-trigger)()
  142.   entry-trigger)
  143.  
  144. (defmethod (box :exit-trigger)()
  145.   exit-trigger)
  146.  
  147. (defmethod (box :set-entry-trigger)(quoted-trigger-procedure)
  148.   (setq entry-trigger quoted-trigger-procedure))
  149.  
  150. (defmethod (box :set-exit-trigger)(quoted-trigger-procedure)
  151.   (setq exit-trigger quoted-trigger-procedure))
  152.  
  153. (defmethod (box :do-trigger-entry-stuff)()
  154.   (let ((trigproc (or
  155.             (cdr (assq 'bu::entry-trigger static-variables-alist))
  156.               entry-trigger)))
  157.     (when (not (null trigproc))(boxer-funcall trigproc))))
  158.  
  159. (defmethod (box :do-trigger-entry-stuff)()
  160.   (let ((trigproc (or
  161. ;            (boxer-funcall 'bu:first
  162. ;                    (boxer-funcall 'bu:get-named self      
  163. ;                              (make-box '((trigger-entry)))))
  164.               entry-trigger)))
  165.     (when (not (null trigproc))(boxer-funcall trigproc))))
  166.  
  167. (defmethod (box :do-trigger-exit-stuff)()
  168.   (let ((trigproc (or
  169. ;            (boxer-funcall 'bu:first
  170. ;                    (boxer-funcall 'bu:get-named self 
  171. ;                           (make-box '((trigger-exit)))))
  172.               exit-trigger)))
  173.     (when (not (null trigproc))(boxer-funcall trigproc))))
  174.  
  175.  
  176. (defmethod (box :enable-entry-trigger)()
  177.   (setq entry-trigger-flag 'enabled))
  178.  
  179. (defmethod (box :disable-entry-trigger)()
  180.   (setq entry-trigger-flag 'disabled))
  181.  
  182. (defmethod (box :enable-exit-trigger)()
  183.   (setq exit-trigger-flag 'enabled))
  184.  
  185. (defmethod (box :disable-exit-trigger)()
  186.   (setq exit-trigger-flag 'disabled))
  187.  
  188.  
  189. (DEFMETHOD (BOX :EXIT-TRIGGER-ENABLED?) ()
  190.   (EQ EXIT-TRIGGER-FLAG 'ENABLED))
  191.  
  192. (DEFMETHOD (BOX :ENTRY-TRIGGER-ENABLED?) ()
  193.   (EQ ENTRY-TRIGGER-FLAG 'ENABLED))
  194.  
  195.  
  196. (defboxer-function enable-entry-trigger ((list-rest box))
  197.   (tell (car box) :enable-entry-trigger)
  198.   :noprint)
  199.